#Načtení všech potřebných knihoven
#pro přípravu dat na modelování
library(quanteda)
## Package version: 3.3.1
## Unicode version: 14.0
## ICU version: 71.1
## Parallel computing: 8 of 8 threads used.
## See https://quanteda.io for tutorials and examples.
library(quanteda.textstats)
library(quanteda.textplots)
library(topicmodels)
library(readtext)
##
## Attaching package: 'readtext'
## The following object is masked from 'package:quanteda':
##
## texts
library(tidytext)
library(dplyr)
##
## Attaching package: 'dplyr'
## The following objects are masked from 'package:stats':
##
## filter, lag
## The following objects are masked from 'package:base':
##
## intersect, setdiff, setequal, union
library(reshape2)
library(jsonlite)
library(readxl)
library(stringr)
#pro vizualizaci
library(LDAvis)
library(wordcloud)
## Loading required package: RColorBrewer
library(ggplot2)
library(gridExtra)
##
## Attaching package: 'gridExtra'
## The following object is masked from 'package:dplyr':
##
## combine
library(RColorBrewer)
library(forcats)
#model není nutné opakovaně spouštět - lze načíst Rdata environment
load("topic_model.RData")
Načtení všech připravených txt souborů z adresáře:
current_working_directory <- getwd() # nastavený pracovní adresář, předpokládá se adresář, kde je uložen tento script
relative_path_to_data <- "/data/*.txt" # podadresář se soubory
full_path <- paste0(current_working_directory,relative_path_to_data) # celá cesta k souborům
corpus <- corpus(readtext(full_path)) # načtení ve formě corpusu knihovny quanteda
Načtená data ze souborů je třeba rozložit na jednotlivé tokeny a
vytvořit matici dokument-slovo (documet-term matrix).
K načtení a manipulaci s daty se používá knihovna
quanteda.
V rámci transformace do matice je možné odstranit z korpusu tzv. stop slova.
# slova objevující se napříč všemi *Rozpravami* (zanedbatelný vliv na témata)
stop_CAVU <- c("akademie", "strana", "rozprava", "obsah", "fig", "tab", "pag", "hodina", "metr", "pozorování", "maximum", "den", "rok", "datum", "milimetr", "vel", "průměr", "minimum", "maximum", "stupeň", "leden", "únor", "březen", "duben", "květen", "červen", "červenec", "srpen", "září", "říjen", "listopad", "prosinec")
# nevýznamová slova a znaky v korpusu
stop_nonsense <- c("wsw", "nnw", "ssw", "wnw", "ene", "sse", "eše", "nne", "»", "«", "^", "srv", "srv", "ccm", "dod", "vyn", "tim", "vin", "kol", "ott", "oti", "jah", "upd", "rkp", "srvn", "stsl", "ghm", "srva", "pis", "cxo", "mgh")
# rozdělení na tokeny pro quantida
tokens <- tokens(corpus) %>%
tokens_remove(c(stop_CAVU,stop_nonsense))
# matice dokument-slovo
dfm <- dfm(tokens)
dfm_df <- t(as.data.frame(dfm)) # matice dokument-slovo jako data frame pro lepší zobrazení
Z matice je možné získat jednoduchý přehed o nejfrekventovanějších slovech v korpusu.
freq <- textstat_frequency(dfm, n = 20)
head(freq, 20)
## feature frequency rank docfreq group
## 1 případ 15438 1 746 all
## 2 část 12997 2 735 all
## 3 pokus 12965 3 478 all
## 4 list 12442 4 238 all
## 5 místo 11966 5 685 all
## 6 bod 11572 6 389 all
## 7 doba 10766 7 655 all
## 8 slovo 9866 8 298 all
## 9 buňka 9474 9 235 all
## 10 obrázek 9403 10 423 all
## 11 právo 7988 11 284 all
## 12 tvar 7898 12 566 all
## 13 plocha 7737 13 412 all
## 14 konec 7477 14 614 all
## 15 voda 6997 15 458 all
## 16 roztok 6944 16 350 all
## 17 kyselina 6744 17 304 all
## 18 druh 6625 18 504 all
## 19 způsob 6350 19 667 all
## 20 řada 6112 20 689 all
Pro modelování témat metodou LDA je využita knihovna
topicmodels. Ta pracuje s jinak strukturovanou maticí
dokument-slovo, je proto potřeba výše vytvořenou matici do této
podoby převést.
dtm <- convert(dfm, to = "topicmodels")
Spuštění LDA si vyžaduje stanovit proměnnou k, která
určí, kolik témat se má v korpusu identifikovat. Bylo stanoveno, že
model má rozpoznat 35 témat. Pomocí třídy control je možné
nastavit další parametry. Je takto určena hodnota alpha.
Čím je alpha vyšší, tím větší množství témat se může
objevovat v jednom dokumentu. V našem případě je nastavena na
0.1, neboť předpokládáme, že jedno číslo Rozprav
se pravděpodobně věnovalo jednomu tématu. Hodnoty dalších parametrů jsou
ponechány ve výchozím nastavení[^https://cran.r-project.org/web/packages/topicmodels/topicmodels.pdf],
počet iterací Gibbsova vzorkování je v takovém případě 2000.
Dále je vhodné použít před spuštěním modelu funkci
set.seed, která slouží k vytváření reprodukovatelných
výsledků v případech, kdy se vytváří proměnné nabývající náhodných
hodnot. Zaručuje se tak, že při každém spuštění kódu budou vytvořeny
stejné náhodné hodnoty.
set.seed(1234)
topic_model <- LDA(dtm, method = "Gibbs", k = 35, control = list(alpha = 0.1))
topic_model
LDA vytvoří matici slovo-téma, ve které je u každého slova z
korpusu uvedeno s jakou pravděpodobností bylo vygenerováno z jakého
tématu. Tato pravděpodobnost je označena jako beta. Model
témata nijak nepojmenuje, označena jsou pouze čísly.
word_topics <- tidy(topic_model, matrix="beta")
word_topics
## # A tibble: 4,668,755 × 3
## topic term beta
## <int> <chr> <dbl>
## 1 1 rejstřík 0.00000160
## 2 2 rejstřík 0.00000115
## 3 3 rejstřík 0.000237
## 4 4 rejstřík 0.00000155
## 5 5 rejstřík 0.00000296
## 6 6 rejstřík 0.00000114
## 7 7 rejstřík 0.000160
## 8 8 rejstřík 0.000000951
## 9 9 rejstřík 0.0000630
## 10 10 rejstřík 0.00000366
## # ℹ 4,668,745 more rows
Pro každé téma je možné zobrazit stanovený počet slov, která se v něm vyskytují s nejvyšší frekvencí:
topic_number <- 8 # příklad pro téma č. 8
word_topic_posterior <- posterior(topic_model)$terms[topic_number, ]
top_words_for_topicX <- head(sort(word_topic_posterior, decreasing = T), n=50)
head(top_words_for_topicX)
## buňka jádro hmota vlákno útvar bakterie
## 0.051016457 0.039152165 0.016222778 0.011713015 0.009382020 0.008963392
Nejfrekventovanější slova tématu je také možné zobrazit jako wordcloud:
wordcloud(names(top_words_for_topicX), top_words_for_topicX)
Druhým výstupem LDA je matice popisující pravděpodobnost příslušnosti
dokumentu ke konkrétnímu tématu určená proměnnou gamma.
LDA přiřadí každému slovu v dokumentu téma. Čím více slov v dokumentu
je přiřazeno k jednomu tématu, tím větší hodnotu má proměnná
gamma a tím spíš pojednává dokument o daném tématu.
gamma tedy udává odhadovanou proporci slov v dokumentu,
která byla vygenerována z konkrétního tématu.
topic_model_documents <- tidy(topic_model, matrix = "gamma")
topic_model_documents
## # A tibble: 31,045 × 3
## document topic gamma
## <chr> <int> <dbl>
## 1 LDA_PREPARED_NOUNS_PREPARED_TEXT_OCR_vol_1891_-_1892_No_1_c255… 1 1.09e-4
## 2 LDA_PREPARED_NOUNS_PREPARED_TEXT_OCR_vol_1891_-_1892_No_10_c25… 1 3.71e-4
## 3 LDA_PREPARED_NOUNS_PREPARED_TEXT_OCR_vol_1891_-_1892_No_11_c25… 1 3.44e-3
## 4 LDA_PREPARED_NOUNS_PREPARED_TEXT_OCR_vol_1891_-_1892_No_11_c25… 1 2.31e-3
## 5 LDA_PREPARED_NOUNS_PREPARED_TEXT_OCR_vol_1891_-_1892_No_13_c25… 1 1.12e-4
## 6 LDA_PREPARED_NOUNS_PREPARED_TEXT_OCR_vol_1891_-_1892_No_14_c25… 1 1.50e-3
## 7 LDA_PREPARED_NOUNS_PREPARED_TEXT_OCR_vol_1891_-_1892_No_15_c25… 1 7.42e-5
## 8 LDA_PREPARED_NOUNS_PREPARED_TEXT_OCR_vol_1891_-_1892_No_16_c25… 1 6.50e-3
## 9 LDA_PREPARED_NOUNS_PREPARED_TEXT_OCR_vol_1891_-_1892_No_17_c25… 1 1.21e-3
## 10 LDA_PREPARED_NOUNS_PREPARED_TEXT_OCR_vol_1891_-_1892_No_18_c25… 1 8.56e-5
## # ℹ 31,035 more rows
document_to_topic <- topic_model_documents %>%
group_by(document) %>%
slice_max(gamma) %>%
ungroup()
Také je možné vyfiltrovat všechny dokumenty, které patří k vybranému tématu:
topic_number <- 1 # vybrané téma
document_topic_filtr <- filter(document_to_topic, document_to_topic$topic == topic_number)
document_topic_filtr
## # A tibble: 28 × 3
## document topic gamma
## <chr> <int> <dbl>
## 1 LDA_PREPARED_NOUNS_PREPARED_TEXT_OCR_vol_1891_-_1892_No_39_c256c… 1 0.528
## 2 LDA_PREPARED_NOUNS_PREPARED_TEXT_OCR_vol_1896_No_7_c245da5f-435d… 1 0.473
## 3 LDA_PREPARED_NOUNS_PREPARED_TEXT_OCR_vol_1899_No_10_c23e5fe8-435… 1 0.525
## 4 LDA_PREPARED_NOUNS_PREPARED_TEXT_OCR_vol_1899_No_11_c23e5fe9-435… 1 0.477
## 5 LDA_PREPARED_NOUNS_PREPARED_TEXT_OCR_vol_1899_No_19_c23eae11-435… 1 0.739
## 6 LDA_PREPARED_NOUNS_PREPARED_TEXT_OCR_vol_1899_No_1_c23e11bf-435d… 1 0.359
## 7 LDA_PREPARED_NOUNS_PREPARED_TEXT_OCR_vol_1901_No_1_c23bc7ac-435d… 1 0.838
## 8 LDA_PREPARED_NOUNS_PREPARED_TEXT_OCR_vol_1901_No_39_c2351198-435… 1 0.443
## 9 LDA_PREPARED_NOUNS_PREPARED_TEXT_OCR_vol_1902_No_16_c23781aa-435… 1 0.980
## 10 LDA_PREPARED_NOUNS_PREPARED_TEXT_OCR_vol_1902_No_32_c237f6ea-435… 1 0.945
## # ℹ 18 more rows
Model rozpoznaná témata v korpusu označuje pouze číslem, jejich vhodné pojmenování závisí na vlastní interpretaci badatele. Za tímto účelem byly využity 3 techniky. Nejefektivnější a nejjednodušší přístup k pojmenování témat je zhodnotit nejfrekventovaněší slova, která se v každém tématu vyskytují. Pokud tato technika nevedla k intuitivnímu pojmenování, byl analyzován začátek plného textu dokumentů patřících k danému tématu s nejvyšší pravděpodobností. Nepomohla-li ani tato technika jednoznačně určit vhodný název pro téma, byly z matice dokument-téma získány identifikátory jednotlivých svazků patřících do tématu, pomocí identifikátoru byl sestaven odkaz do digitální knihovny a byl analyzován přímo zdrojový digitalizát.
Nejfrekventovanější slova
Pro pojmenování témat pomocí nejfrekventovanějších slov, jež se v něm vyskytují, může posloužit například jednoduchý tabulkový přehled:
# vytvoření data frame pro přehledné zobrazení:
word_topics_TOPterms_df <-as.data.frame((terms(topic_model, 30))) # 30 nejfrekventovanějších slov pro každé téma
word_topics_TOPterms_df
## Topic 1 Topic 2 Topic 3 Topic 4 Topic 5 Topic 6 Topic 7
## 1 rostlina slovo list list fosfor bod právo
## 2 pokus tvar král špička sklo přímka zákon
## 3 pupen koncovka císař druh huť rovina statek
## 4 list jméno vévoda okraj hut křivka soud
## 5 poloha lidé zpráva lod hutmistr plocha případ
## 6 děloha les kurfiřt mech panství tečna dílo
## 7 teplo sloveso jednání tobolka les střed prodej
## 8 část číslo vojsko buňka sklárna osa povinnost
## 9 doba souhláska věc konec kopa kružnice zboží
## 10 vrchol nářečí vévod hora dříví paprsek doba
## 11 teplota pole mír skála úřad křivost ustanovení
## 12 pohyb samohláska kníže rostlina oves kuželosečka příčina
## 13 lístek jazyk válka rod léta svazek osoba
## 14 osa poznámka země lodyžka vrchnost rychlost způsob
## 15 rostlinka vzor rada sucho kilogram případ řád
## 16 světlo cena nepřítel čep plat soustava jistota
## 17 případ kůň cesta les sklenice vrchol věc
## 18 vliv místo pomoc větev závod konstrukce místo
## 19 vzrůst voň doba žebro hrabě rovnice autor
## 20 zakřivení skupina vyslanec stěna kop obrázek řízení
## 21 výměna žena čas barva hejtman pól škoda
## 22 lodyha voda opat prstenec vazba průmět žák
## 23 směr člověk plán větévka příloha čára slovo
## 24 látka rod stav polštářek cena poloměr země
## 25 kyslík vesnice slovo část sboží průsečík cena
## 26 kořen noc žádost forma sklenář komplex listina
## 27 obrázek muž dvůr řada obchodník involuce smlouva
## 28 dítě dům poznámka base rychtář parabola trest
## 29 kokotice přípona říše stélka soused úhel část
## 30 plyn předložka kardinál vlášení archiv kolmice základ
## Topic 8 Topic 9 Topic 10 Topic 11 Topic 12 Topic 13
## 1 buňka rybník pruh rovnice nerv text
## 2 jádro směr spektrum řada vlákno slovo
## 3 hmota pravděpodobnost roztok funkce oko legenda
## 4 vlákno měsíc voda hodnota papilla památka
## 5 útvar oblast barvivo vzorec myotom souhláska
## 6 bakterie are skupina číslo svazek výslovnost
## 7 krvinka doba chlorid výraz část samohláska
## 8 obrázek substantivum poloha sin snopec spis
## 9 leukocyt zima pásek forma sítnice řád
## 10 tělo tůně sloučenina veličina kořen skupina
## 11 struktura srovn zárodek člen mícha hláska
## 12 případ skupina přísada tvar větev jazyk
## 13 tvar rybníček páska případ ryba tisk
## 14 změna minuta ammoniak integrál směr čeština
## 15 obraz jaro obrázek cos svazeček prs
## 16 část slabika mikrob počet mesoblastsomit modlitba
## 17 zrnko povodí studna log kmen překlad
## 18 práce léto vrstva výsledek štěrbina souhl
## 19 zrno srážka tekutina podmínka céva pravopis
## 20 forma ruš effekt součet pochva zvuk
## 21 výběžek perioda pošinutí věta vrstva vliv
## 22 tělisko maž zeleň vztah ganglium homilie
## 23 element koř filtr kořen průběh místo
## 24 plasma dto filtrace determinant embryo část
## 25 doba přípona zkouška koefficient těleso formule
## 26 methoda podzim počet rozvoj hypogloss dvojhláska
## 27 místo rod pásmo místo pruh artikulace
## 28 pochod význam tinktura proměnná průřez cena
## 29 dělení nástup délka substituce výběžek rukopis
## 30 protoplasma hodnota thionin způsob základ éro
## Topic 14 Topic 15 Topic 16 Topic 17 Topic 18 Topic 19 Topic 20
## 1 případ věta představa taxa list pokus lebka
## 2 nádor koř pojem vaz mistr tlak případ
## 3 ledvina spojka výsledek úřad král injekce prst
## 4 tkáň verš případ posice město tep roh
## 5 vřed doklad zákon kolek písař zvíře část
## 6 okraj hexametr věc řád malíř pes mícha
## 7 žláza optativ stav kdo pán minuta dítě
## 8 místo caesura soud arch doba účinek index
## 9 vrstva stopa dojem tax kniha dýchání typ
## 10 víčko polovice otázka třída obraz extrakt ruka
## 11 kůže člen smysl gen pan centimetr kost
## 12 část sloveso vědomí impt syn nadledvinka počet
## 13 kysta příklad cit čára léta dráždění palec
## 14 povrch vil theorie pól kancelář mícha provazec
## 15 rána začátek zjev rekurrent jméno vag kůstka
## 16 oko místo činnost poplatek klášter počet výška
## 17 řez hlas slovo patent stav výtažek článek
## 18 stěna slovo příčina zřízenec osoba hyoscin délka
## 19 vazivo otázka poznání město zápis srdce kloub
## 20 nemocný pan názor praes kostel změna noha
## 21 céva případ výklad postik dům dávka hmota
## 22 orgán platnost vina spis právo vteřina nemocný
## 23 změna poznámka význam part čas podráždění končetina
## 24 granulace přívlastek předmět záležitost století klesnutí falanga
## 25 pouzdro konec vůle dávka listina žába hlava
## 26 nález děj stanovisko svěrač sněm působení tělo
## 27 vývod indikativ účel obrna manželství roztok doba
## 28 operace volba část dkt příčina zrychlení šířka
## 29 obraz předvětí možnost addukce biskup žláza tvar
## 30 barva participium pohyb výměra hora čiv změna
## Topic 21 Topic 22 Topic 23 Topic 24 Topic 25 Topic 26 Topic 27
## 1 jedinec kyselina sval hornina opis proud druh
## 2 síla roztok pokus břidlice denár odpor vrstva
## 3 půda voda podnět křemen mince intensita obrázek
## 4 kořínek pokus podráždění hmota rub hodnota jehlice
## 5 mykorrhiza množství nerv živec líc měření část
## 6 kultura sůl intensita lom groš pokus jíl
## 7 houba látka proud místo král centimetr okraj
## 8 případ centimetr křivka část ruka síla tvar
## 9 část váha činnost směr kříž elektroda sloj
## 10 hyfa reakce změna vrstva doba vzdálenost písek
## 11 obtížení kysličník rychlost ruda syn pole rod
## 12 soustava methoda čivost pásmo povídka směr místo
## 13 vrstva tekutina elektroda vápenec jméno drát povrch
## 14 povrch vzduch zkrácení amfibol obyčej doba konec
## 15 nosník teplota teplota barva lid změna délka
## 16 tělo výsledek oddíl zrno kaplice obrázek exemplář
## 17 těleso číslo reakce kamení látka anoda zbytek
## 18 obrázek kyslík vliv pyrit obřad případ naleziště
## 19 vlákno alkohol účin žíla obraz výsledek směr
## 20 humus směs obrázek biotit žena potenciál uhlí
## 21 druh práce smrštění zrnko hlava vrstva kost
## 22 kloub rozklad skupina partie obvodek deska zvířena
## 23 reakce sloučenina výška pískovec země délka hlína
## 24 mykorrhiz část doba potok peníze paprsek prof
## 25 pole cukr poměr porfyr věštba tabulka doba
## 26 vzrůst poměr kontrakce údolí nález stroj okolí
## 27 prut doba působivost nerost oheň polarisace vápenec
## 28 plášť dusík rozdíl puklina dívka způsob pásmo
## 29 pořadnice vodík latence augit mincovna práce šířka
## 30 doba způsob pohyb okolí hřivna roztok zkamenělina
## Topic 28 Topic 29 Topic 30 Topic 31 Topic 32 Topic 33 Topic 34
## 1 plocha list buňka případ slovo hora spis
## 2 hvězda obrázek řez pokus místo řeka píseň
## 3 krystal kraj část krev verš hranice slovo
## 4 tvar konec embryo zvíře výklad jméno dílo
## 5 úhel kroužek obrázek kultura vazba část list
## 6 krystall květ místo moč násl voda text
## 7 obrázek část stěna bacill význam moře vydání
## 8 hrana rod epithel slezina zájmeno doba nota
## 9 hodnota druh kanálek mikrob výraz místo kniha
## 10 hranol článek vrstva nález příklad území doba
## 11 měření osa klička králík čtení kmen místo
## 12 čas křídlo dutina injekce smysl zpráva číslo
## 13 obraz větev směr krvinka podání pramen věc
## 14 pásmo lístek stadium teplota příčina jezero hlas
## 15 pyramida tyčinka céva změna konjektura cesta zpěv
## 16 typ tvar konec doba mínění krajina práce
## 17 chyba květenství střevo množství nása břeh jazyk
## 18 osa šupina roura anaemie řeč město zpráva
## 19 poznámka listen sliznice příznak užívání rovina bůh
## 20 výpočet chlopeň vajíčko váha rukopis poměry konec
## 21 světlost vajíčko vývoj tělo spojení sídlo kancionál
## 22 reflex svazek vývod reakce věta sever verš
## 23 velikost tělo lumen účinek doba východ socha
## 24 průchod kořen váček infekce tvar obyvatelstvo umění
## 25 litr kruh zóna barvivo případ údolí díl
## 26 poloha hlava doba příčina básník okrsek studie
## 27 pól případ spojení nemocný osoba ostrov báseň
## 28 část délka nadledvina místo text půda léta
## 29 minuta počet poměry půda způsob tok sbírka
## 30 pruh plocha pruh výsledek jméno země pramen
## Topic 35
## 1 hra
## 2 kmen
## 3 koncovka
## 4 tvar
## 5 slovo
## 6 výklad
## 7 div
## 8 slovanština
## 9 jazyk
## 10 deklinace
## 11 tělo
## 12 nom
## 13 intonace
## 14 řeč
## 15 lit
## 16 drama
## 17 přípona
## 18 hrob
## 19 pád
## 20 význam
## 21 jeviště
## 22 představení
## 23 lok
## 24 nominativ
## 25 lat
## 26 případ
## 27 akk
## 28 pravda
## 29 slabika
## 30 třída
Zobrazení nejfrekventovanějších slov jednoho vybraného tématu v tabulce:
# Tabulka pro jedno téma
word_topics_TOPterms_df$`Topic 8`
## [1] "buňka" "jádro" "hmota" "vlákno" "útvar"
## [6] "bakterie" "krvinka" "obrázek" "leukocyt" "tělo"
## [11] "struktura" "případ" "tvar" "změna" "obraz"
## [16] "část" "zrnko" "práce" "zrno" "forma"
## [21] "výběžek" "tělisko" "element" "plasma" "doba"
## [26] "methoda" "místo" "pochod" "dělení" "protoplasma"
# formátování:
word_topics_TOPterms_df_table <- knitr::kable(word_topics_TOPterms_df$`Topic 17`,
col.names = c("Nejčastější termíny"))
Kromě tabulkového přehledu je možné využít také vizualizaci pomoci
knihovny LDAvis, která převede mnohorozměrná témata modelu
do dvou dimenzí tak, aby bylo možné je jednoduše a interaktivně
prezentovat. Výstupem je jednoduchá javascriptová aplikace, která
umožňuje prozkoumávat výsledky LDA pomocí zaměření se na konkrétní
témata nebo slova.
Velikost kruhů ve vizualizaci reprezentující témata odpovídá tomu, kolik tokenů (slov) je k tématu přiřazeno (v pravém horním rohu se ukazuje přesné procentuální vyčíslení). Velikost tak odpovídá důležitosti daného tématu v korpusu. Z vizualizace lze také z blízkosti kruhů odvodit, která témata jsou si sémanticky podobná či se překrývají:
dtm = dtm[slam::row_sums(dtm) > 0, ]
phi = as.matrix(posterior(topic_model)$terms)
theta <- as.matrix(posterior(topic_model)$topics)
vocab <- colnames(phi)
doc.length = slam::row_sums(dtm)
term.freq = slam::col_sums(dtm)[match(vocab, colnames(dtm))]
json = createJSON(phi = phi, theta = theta, vocab = vocab,
doc.length = doc.length, term.frequency = term.freq, reorder.topics = FALSE)
serVis(json)
## Loading required namespace: servr
Náhled vstupních dokumentů
Pokud by pro pojmenování témat nestačil přehled nejfrekventovanějších slov, je možné z matice téma-dokument získat dokumenty s největší pravděpodobtí příslušnosti k jednotlivým tématům a podívat se na jejich plný text, nebo jeho část. Je ovšem potřeba mít na paměti, že plným textem je pro potřeby modelu již upravený textový soubor obsahující pouze podstatná jména v základním tvaru.
topic_number <- 8 # vybrané téma
document_topic_filtr <- filter(document_to_topic, document_to_topic$topic == topic_number)
document_topic_filtr
## # A tibble: 44 × 3
## document topic gamma
## <chr> <int> <dbl>
## 1 LDA_PREPARED_NOUNS_PREPARED_TEXT_OCR_vol_1891_-_1892_No_11_c2560… 8 0.694
## 2 LDA_PREPARED_NOUNS_PREPARED_TEXT_OCR_vol_1891_-_1892_No_13_c2562… 8 0.807
## 3 LDA_PREPARED_NOUNS_PREPARED_TEXT_OCR_vol_1891_-_1892_No_22_c2565… 8 0.894
## 4 LDA_PREPARED_NOUNS_PREPARED_TEXT_OCR_vol_1893_No_13_c25199b9-435… 8 0.894
## 5 LDA_PREPARED_NOUNS_PREPARED_TEXT_OCR_vol_1893_No_31_c253959c-435… 8 0.637
## 6 LDA_PREPARED_NOUNS_PREPARED_TEXT_OCR_vol_1893_No_38_c253bcb3-435… 8 0.490
## 7 LDA_PREPARED_NOUNS_PREPARED_TEXT_OCR_vol_1893_No_8_c25172a4-435d… 8 0.805
## 8 LDA_PREPARED_NOUNS_PREPARED_TEXT_OCR_vol_1894_No_16_c248bfcc-435… 8 0.495
## 9 LDA_PREPARED_NOUNS_PREPARED_TEXT_OCR_vol_1894_No_21_c248e6e1-435… 8 0.944
## 10 LDA_PREPARED_NOUNS_PREPARED_TEXT_OCR_vol_1894_No_22_c2490df2-435… 8 0.743
## # ℹ 34 more rows
# získání textu dokumentu
document_number <- 8 # číslo vybraného dokumentu
document_name <- document_topic_filtr$document[document_number] # označení vybraného dokumentu
document_to_preview <- corpus[[document_name]] # přístup k textu v načteném korpusu
# zobrazení textu
document_to_preview <- gsub("\n", " ", document_to_preview) # vytvoření mezer
substr(document_to_preview, 1, 1000) # zobrazí prvních 1000 znaků
## [1] "ročník třída číslo MUDr vyobrazení podpora akademie císař věda slovesnost umění ústava pathologie prof DRA den duben odbor medicína objev ráz směr badání aetiologie choroba obrat therapie literatura léta nemoc mikrob čelo aetiologie choroba výtvor škůdce therapie nález nouze medikament tvrzení schopnost mikrob tělo vývoj tělo účinek jed druh živočišstvo mikrob vlastnost člověk zvíře zkoumání otázka immunita boj tábor síla boj domněnka Mfč odpor strana doklad tvrzení mínění tábor důkaz tábor spor světlo řada poznání zkušenost stoupenec vliv působení zápas organismus mikrob leukocytň místo očkování množství doba bakterie část phagocyt zjev phagocytosa strana vliv šťáva buňka přítomnost leukocyt místo důležitost bud působení krvinka útvar strana působení látka mikrob vliv tkáň síla přitažlivost zjev hromadění autor přitahování leukocyt chemotaxe citlivost leukocyt zjev immunita sesílení tělo záruka působení bakterie zničení tělo phagocytosa chemotaxe tělo therapie citlivost krvinka hromad"
#print(document_to_preview) # zobrazí celý dokument
Odkazy na digitalizáty
V případech, kdy žádná z předchozích technik nevedla k pojmenování
témat, je možné získat z názvů jednotlivých dokumentů jejich
identifikátor uuid, sestavit z něj odkaz do digitální
knihovny a analyzovat přímo zdrojový digitalizát.
topic_number <- 31 # vybrané téma
document_topic_filtr <- filter(document_to_topic, document_to_topic$topic == topic_number)
top_documents <- document_topic_filtr$document
documents_url <- list()
for (txt in 1:length(top_documents)){
doc_uuid <- str_sub(top_documents, -40, -5)
doc_url <- paste0("https://kramerius.lib.cas.cz/uuid/uuid:",doc_uuid)
documents_url <- c(documents_url, doc_url)
}
head(documents_url) #několik prvních dokumentů
## [[1]]
## [1] "https://kramerius.lib.cas.cz/uuid/uuid:c25606d5-435d-11dd-b505-00145e5790ea"
##
## [[2]]
## [1] "https://kramerius.lib.cas.cz/uuid/uuid:c25654fc-435d-11dd-b505-00145e5790ea"
##
## [[3]]
## [1] "https://kramerius.lib.cas.cz/uuid/uuid:c255b8ac-435d-11dd-b505-00145e5790ea"
##
## [[4]]
## [1] "https://kramerius.lib.cas.cz/uuid/uuid:c25199ba-435d-11dd-b505-00145e5790ea"
##
## [[5]]
## [1] "https://kramerius.lib.cas.cz/uuid/uuid:c2534771-435d-11dd-b505-00145e5790ea"
##
## [[6]]
## [1] "https://kramerius.lib.cas.cz/uuid/uuid:c2536e89-435d-11dd-b505-00145e5790ea"
#documents_url #odkazy na všechny dokumenty tématu
Na základě výše zmíněných metod byly tématům přiřazeny názvy.
#pojmenovaná témata
named_topics <- c("01: Fyziologie rostlin a živočichů",
"02: Nářečí",
"03: Politické a sociální dějiny",
"04: Bryologie (mechorosty)",
"05: Sklářství",
"06: Geometrie",
"07: Právo",
"08: Cytologie",
"09: Fyzická geografie českých zemí a nářečí",
"10: Fyzikální chemie",
"11: Matematická analýza",
"12: Nervová a smyslová soustava",
"13: Literární věda a jazykověda",
"14: Patofyziologie",
"15: Syntax",
"16: Filosofie a psychologie",
"17: Fonologie a daně",
"18: Kulturní dějiny",
"19: Fyziologické experimenty",
"20: Anatomie kostí a kloubů",
"21: Systémová analýza",
"22: Chemické prvky a sloučeniny",
"23: Fyziologie svalů",
"24: Petrologie",
"25: Numismatika",
"26: Elektrotechnika",
"27: Geologie a archeologie",
"28: Horniny a kosmická tělesa",
"29: Hmyz a morfologie rostlin",
"30: Embryologie a anatomie orgánů",
"31: Klinické příznaky a léčba nemocí",
"32: Řečtí a římští klasici",
"33: Geografie",
"34: Umění, písemnictví a humanismus",
"35: Staročeská a slovanská kultura")
Identifikovaná témata a jejich publikace je možné propojit s daty o době jejich publikace:
# Spojení identifikovaných témat s roky jejich publikování (na základě metadat z digitální knihovny)
# Načtení JSON s metadaty čísel
file_name <- "combined_issues_publication_year.json" # předpokládá se, že soubor je ve stejné složce jako R script
json_file_path <- file_name
issues_publication_year_data <- fromJSON(json_file_path)
names(issues_publication_year_data)[1] <- "document" # přejmenuje se sloupec s uuid čísel tak, aby odpovídal sloupci v data framu document_to_topic, se kterou budou načtená data spojena
# v data framu document_to_topic je potřeba upravit sloupec obsahující uuid čísla
for (q in 1:nrow(document_to_topic)){ # pro každý řádek
new_string <- paste0("uuid:",str_sub(document_to_topic$document[[q]], -40, -5)) #prefix "uuid:", substring najde uuid, předpokládá se, že název souboru končí .txt
document_to_topic$document[[q]] <- new_string
}
# spojení document_to_topic a načtených dat
document_to_topic_year_data <- merge(document_to_topic, issues_publication_year_data, by = "document", all = TRUE)
# Součet dokumentů věnujících se jednomu tématu
document_counts_per_year <- document_to_topic_year_data %>%
group_by(topic, volume_year, class) %>%
summarise(count = n(), .groups = 'drop')
# konverze kvůli problémům při řazení při zobrazení v grafu
document_counts_per_year$volume_year <- as.character(document_counts_per_year$volume_year)
document_counts_per_year$topic <- as.factor(document_counts_per_year$topic)
document_counts_per_year$volume_year <- sub(" - .*", "", document_counts_per_year$volume_year)
Pro popis jednotlivých témat byla vytvořena funkce
getTopicOverview(topic_number), která zajistí vytvoření
wordcloudu (getTopicWorldCloud), přehledu počtu vydaných
svazků v jednotlivých letech sledovaného období
(getTopicOverYearsGraph) a zjistí celkový počet svazků
náležících tématu (getTopicDocumentsSum).
#vytvoří wordcloud z nejfrekventovanějších slov tématu
getTopicWorldCloud <- function(topic_number){
word_topic_posterior <- posterior(topic_model)$terms[topic_number, ]
top_words_for_topicX <- head(sort(word_topic_posterior, decreasing = T), n=50)
wordcloud <- wordcloud(names(top_words_for_topicX), top_words_for_topicX)
return(wordcloud)
}
#vytvoří graf ukazující počet dokumentů daného tématu vydaný v jednotlivých letech
getTopicOverYearsGraph <- function(topic_number){
#přehled počtu dokumentů k danému tématu v jednotlivých letech
topic_filter <- filter(document_counts_per_year, document_counts_per_year$topic == topic_number)
all_years <- data.frame(volume_year = 1890:1910) # data frame s rozsahem 1890 to 1910
topic_filter$volume_year <- as.integer(as.character(topic_filter$volume_year)) # konverze volume_year z factor na integer v topic_filter
topic_filter_complete <- left_join(all_years, topic_filter, by = "volume_year")
topic_filter_complete$count[is.na(topic_filter_complete$count)] <- 0 #nahrazení NA nulou
# graf
years_graph <- ggplot(topic_filter_complete, aes(x = volume_year, y = count, fill = class)) +
geom_bar(stat = "identity") +
theme_minimal() +
labs(x = "Roky", y = "Počet dokumentů") +
theme(axis.text.x = element_text(angle = 90, hjust = 1)) +
scale_x_continuous(breaks = 1890:1910)
return(years_graph)
}
#Shrne počet dokumentů ve vybraném tématu
getTopicDocumentsSum <- function(topic_number){
topic_filter_sum <- sum(filter(document_counts_per_year, document_counts_per_year$topic == topic_number)$count)
return(topic_filter_sum)
}
# Vytvoření přehledu pro jednotlivé téma
getTopicOverview <- function(topic_number){
topic_filter_sum <- getTopicDocumentsSum(topic_number)
print(paste0("Počet dokumentů v tématu č.",topic_number," je ",topic_filter_sum))
wordcloud <- getTopicWorldCloud(topic_number)
wordcloud
topic_over_years <- getTopicOverYearsGraph(topic_number)
topic_over_years
}
getTopicOverview(1)
## [1] "Počet dokumentů v tématu č.1 je 28"
getTopicOverview(2)
## [1] "Počet dokumentů v tématu č.2 je 5"
getTopicOverview(3)
## [1] "Počet dokumentů v tématu č.3 je 8"
getTopicOverview(4)
## [1] "Počet dokumentů v tématu č.4 je 10"
getTopicOverview(5)
## [1] "Počet dokumentů v tématu č.5 je 3"
getTopicOverview(6)
## [1] "Počet dokumentů v tématu č.6 je 54"
getTopicOverview(7)
## [1] "Počet dokumentů v tématu č.7 je 8"
getTopicOverview(8)
## [1] "Počet dokumentů v tématu č.8 je 44"
getTopicOverview(9)
## [1] "Počet dokumentů v tématu č.9 je 7"
getTopicOverview(10)
## [1] "Počet dokumentů v tématu č.10 je 11"
getTopicOverview(11)
## [1] "Počet dokumentů v tématu č.11 je 77"
getTopicOverview(12)
## [1] "Počet dokumentů v tématu č.12 je 12"
getTopicOverview(13)
## [1] "Počet dokumentů v tématu č.13 je 3"
getTopicOverview(14)
## [1] "Počet dokumentů v tématu č.14 je 34"
getTopicOverview(15)
## [1] "Počet dokumentů v tématu č.15 je 2"
getTopicOverview(16)
## [1] "Počet dokumentů v tématu č.16 je 5"
getTopicOverview(17)
## [1] "Počet dokumentů v tématu č.17 je 3"
getTopicOverview(18)
## [1] "Počet dokumentů v tématu č.18 je 10"
getTopicOverview(19)
## [1] "Počet dokumentů v tématu č.19 je 51"
getTopicOverview(20)
## [1] "Počet dokumentů v tématu č.20 je 22"
getTopicOverview(21)
## [1] "Počet dokumentů v tématu č.21 je 16"
getTopicOverview(22)
## [1] "Počet dokumentů v tématu č.22 je 119"
getTopicOverview(23)
## [1] "Počet dokumentů v tématu č.23 je 7"
getTopicOverview(24)
## [1] "Počet dokumentů v tématu č.24 je 29"
getTopicOverview(25)
## [1] "Počet dokumentů v tématu č.25 je 7"
getTopicOverview(26)
## [1] "Počet dokumentů v tématu č.26 je 35"
getTopicOverview(27)
## [1] "Počet dokumentů v tématu č.27 je 47"
getTopicOverview(28)
## [1] "Počet dokumentů v tématu č.28 je 50"
getTopicOverview(29)
## [1] "Počet dokumentů v tématu č.29 je 38"
getTopicOverview(30)
## [1] "Počet dokumentů v tématu č.30 je 44"
getTopicOverview(31)
## [1] "Počet dokumentů v tématu č.31 je 52"
getTopicOverview(32)
## [1] "Počet dokumentů v tématu č.32 je 7"
getTopicOverview(33)
## [1] "Počet dokumentů v tématu č.33 je 8"
getTopicOverview(34)
## [1] "Počet dokumentů v tématu č.34 je 28"
getTopicOverview(35)
## [1] "Počet dokumentů v tématu č.35 je 3"
Zobrazení sloupcových grafů pro nejfrekventovanější slova ve všech tématech:
word_topics_TOPterms <- word_topics %>%
mutate(topic = named_topics[topic]) %>% #pojmenování témat
group_by(topic) %>% # pro každé téma...
slice_max(beta, n = 10) %>% # ...10 nejpravděpodobnějších slov
ungroup() %>%
arrange(topic, -beta)
word_topics_TOPterms %>%
mutate(term = reorder_within(term, beta, topic)) %>%
ggplot(aes(beta, term)) +
geom_col(show.legend = FALSE) +
facet_wrap(~ topic, scales = "free") +
theme(strip.text.x = element_text(size = 8)) +
labs(x = "Pravděpodobnost příslušnosti k tématu",
y = "Nejfrekventovanější slova") +
scale_y_reordered()
Graf ukazující počet dokumentů patřících k jednotlivým tématům:
document_to_topics_count <- document_to_topic %>%
mutate(topic = named_topics[topic]) %>% #pojmenování témat
group_by(topic) %>%
summarise(count = n(), .groups = 'drop')
ggplot(document_to_topics_count, aes(x = factor(topic), y = count)) +
geom_bar(stat = "identity", fill="#12448B") +
theme_minimal() +
labs(x = "Téma",
y = "Počet dokumentů") +
theme(axis.text.x = element_text(angle = 70, hjust = 1))
# s rozdělením na třídy
document_to_topics_count <- document_to_topic_year_data %>%
mutate(topic = named_topics[topic]) %>% #pojmenování témat
group_by(topic, class) %>%
summarise(count = n(), .groups = 'drop')
ggplot(document_to_topics_count, aes(x = factor(topic), y = count, fill=class)) +
geom_bar(stat = "identity") +
theme_minimal() +
labs(x = "Téma",
y = "Počet dokumentů",
fill = "Třída") +
scale_fill_manual(values=c("#006837", "#A50026", "#3288BD"))+
theme(axis.text.x = element_text(angle = 80, hjust = 1)) #pro zvětšení písma lze použít: text=element_text(size=25)
Jednotlivá témata byla klasifikována do obecnějších kategorií vycházející z klasifikace FORD a také vědních oblastí a sekcí, do kterých je v současnosti organizována Akademie věd ČR.
Načtení souboru s klasifikací:
topic_classification <- read_excel("klasifikace_temat.xlsx")
topic_classification
## # A tibble: 35 × 11
## `Číslo tématu` `Název tématu` `počet svazků` `metoda určení` `Sekce vědy`
## <dbl> <chr> <dbl> <chr> <chr>
## 1 1 Fyziologie rostli… 28 nejfrekventova… biologické …
## 2 2 Nářečí 5 nejfrekventova… humanitní a…
## 3 3 Politické a sociá… 8 nejfrekventova… historické …
## 4 4 Bryologie (mechor… 10 digitalizáty biologické …
## 5 5 Sklářství 3 digitalizáty vědy o zemi
## 6 6 Geometrie 54 nejfrekventova… matematika,…
## 7 7 Právo 8 nejfrekventova… interdiscip…
## 8 8 Cytologie 44 náhledy vstupn… biologické …
## 9 9 Fyzická geografie… 7 digitalizáty interdiscip…
## 10 10 Fyzikální chemie 11 náhledy vstupn… chemické vě…
## # ℹ 25 more rows
## # ℹ 6 more variables: `Oblast vědy` <chr>, `FORD 2Lvl` <chr>,
## # `FORD 2Lvl FULL` <chr>, `FORD Broad` <chr>, `FORD Broad FULL` <chr>,
## # pozn <chr>
Graf ukazující počet dokumentů patřících k jednotlivým sekcím vědních oblastí AV ČR:
topic_classification_sections <- topic_classification %>%
filter(`Oblast vědy` != "NA") %>%
group_by(`Sekce vědy`, `Oblast vědy`) %>%
summarise(`počet svazků` = sum(`počet svazků`, na.rm = TRUE), .groups = 'drop')
topic_classification_Ford_2nd_Level <- topic_classification %>%
group_by(topic_classification[7], topic_classification[10]) %>%
summarise(`počet svazků` = sum(`počet svazků`, na.rm = TRUE), .groups = 'drop')
ggplot(topic_classification_sections, aes(x = `Sekce vědy`, y = `počet svazků`, fill = `Oblast vědy`)) +
geom_bar(stat = "identity", position = "stack") +
theme_minimal() +
labs(x = "Sekce vědních oblasti",
y = "Počet dokumentů",
fill = "Oblast vědy") +
scale_fill_manual(values=c("#5a1628", "gray", "#12448B", "#005417"))+
theme(axis.text.x = element_text(angle = 70, hjust = 1, size = rel(1.6)))
Graf ukazující počet dokumentů patřících k jednotlivým oborovým skupinám FORD:
ggplot(topic_classification_Ford_2nd_Level, aes(x = `FORD Broad FULL`, y = `počet svazků`, fill = `FORD 2Lvl`)) +
geom_bar(stat = "identity", position = "stack") +
theme_minimal() +
labs(x = "Oborové skupiny FORD",
y = "Počet dokumentů",
fill = "Vědní obory FORD") +
scale_fill_manual(values=c("#A50026", "#D73027", "#F46D43", "#FDAE61", "#FEE08B", "#5E4FA2", "#D9EF8B", "#A6D96A", "#66BD63", "#1A9850", "#006837", "#3288BD"))+
theme(axis.text.x = element_text(angle = 70, hjust = 1)) #pro zvětšení textu: text=element_text(size=25)
Rozložení jednotlivých témat v čase
document_counts_per_year_graph <- document_counts_per_year %>%
mutate(topic = named_topics[topic]) %>% #pojmenování témat
filter(topic != "17: Fonologie a daně") %>% # exclude the unwanted topic
filter(topic != "34: Humanismus a umění") %>% # exclude the unwanted topic
group_by(topic, volume_year) %>%
summarise(count = sum(count), .groups = 'drop')
document_counts_per_year_bar <- ggplot(document_counts_per_year_graph, aes(x = volume_year, y = count, fill=topic)) +
geom_bar(stat = "identity") +
theme_minimal() +
labs(x = "Roky",
y = "Počet dokumentů",
fill = "Téma") +
theme(axis.text.x = element_text(angle = 70, hjust = 1))
document_counts_per_year_facet <- ggplot(document_counts_per_year_graph, aes(x = volume_year, y = count, fill=topic)) +
geom_bar(stat = "identity") +
theme_minimal() +
facet_wrap(~ topic, scales = 'free_y') +
labs(x = "Roky",
y = "Počet dokumentů",
fill = "Téma") +
theme(axis.text.x = element_text(angle = 70, hjust = 1))
ggplot(document_counts_per_year_graph, aes(x = volume_year, y = fct_rev(topic), fill = count)) +
geom_tile() +
scale_fill_gradient(low = "#12448B", high = "red") +
theme_minimal() +
labs(x = "Roky", y = "Téma", fill = "Počet dokumentů") +
theme(axis.text.x = element_text(angle = 70, hjust = 1)) # zvětšení textu: text=element_text(size=25)
axis.title.x = element_text()